home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / pars7.exe / BUILDER.PAS < prev    next >
Pascal/Delphi Source File  |  1993-04-29  |  36KB  |  1,203 lines
  1. unit builder;
  2. {$O+,F+}
  3. interface
  4. uses realtype,pars7glb;
  5.  
  6. procedure parsefunction(s:string;var fop:operationpointer;
  7.             var pointx,pointy,pointt,a,b,c,d,e:rpointer;var numop:integer;
  8.            var error:boolean; showprogress:boolean);
  9. implementation
  10.  
  11. type sstring=string;
  12.  
  13.      termsorttype=(variab,constant,brack,minus,sum,diff,prod,divis,
  14.                     intpower,realpower,cosine,sine,expo,logar,sqroot,arctang,
  15.                     square,third,forth,abso,maxim,minim,heavi,
  16.                     phase,randfunc,argu,hypersine,hypercosine,radius,
  17.                     randrand);
  18.  
  19. procedure chopblanks(var s:sstring);  forward;
  20. {deletes all blanks in s}
  21.  
  22. procedure checkbracketnum(s:sstring; var result:boolean); forward;
  23. {checks whether # of '(' equ. # of ')'}
  24.  
  25. procedure checknum(s:sstring;var num:float;var result:boolean); forward;
  26. {checks whether s is a number}
  27.  
  28. procedure checkvar(s:sstring;var varsort:word;var result:boolean); forward;
  29. {checks whether s is a variable string}
  30.  
  31. procedure checkparam(s:sstring;var parsort:word;var result:boolean); forward;
  32. {checks whether s is a parameter string}
  33.  
  34. procedure checkbrack(s:sstring;var s1:sstring;var result:boolean); forward;
  35. {checks whether s =(...(s1)...) and s1 is a valid term}
  36.  
  37. procedure checkmin(s:sstring;var s1:sstring;var result:boolean); forward;
  38. {checks whether s denotes the negative value of a valid operation}
  39.  
  40. procedure checksum(s:sstring;var s1,s2:sstring;var result:boolean); forward;
  41. {checks whether '+' is the primary operation in s}
  42.  
  43. procedure checkdiff(s:sstring;var s1,s2:sstring;var result:boolean); forward;
  44. {checks whether '-' is the primary operation in s}
  45.  
  46. procedure checkprod(s:sstring;var s1,s2:sstring;var result:boolean); forward;
  47. {checks whether '*' is the primary operation in s}
  48.  
  49. procedure checkdiv(s:sstring;var s1,s2:sstring;var result:boolean);  forward;
  50. {checks whether '/' is the primary operation in s}
  51.  
  52. procedure check2varfunct(s:sstring;var s1,s2:sstring;var fsort:
  53.     termsorttype;var result:boolean);  forward;
  54. {checks whether s=f(s1,s2); s1,s2 being valid terms}
  55.  
  56. procedure checkfunct(s:sstring;var s1:sstring;var fsort:termsorttype;
  57. var result:boolean); forward;
  58. {checks whether s denotes the evaluation of a function fsort(s1)}
  59.  
  60. procedure checkintpower(s:sstring;var s1,s2:sstring;var result:boolean); forward;
  61. {checks whether s=s1^s2, s2 integer}
  62.  
  63. procedure checkrealpower(s:sstring;var s1,s2:sstring;var result:boolean); forward;
  64. {checks whether s=s1^s2, s2 real}
  65.  
  66. procedure chopblanks(var s:sstring);
  67. var i:byte;
  68. begin
  69.   while pos(' ',s)>0 do
  70.   begin
  71.     i:=pos(' ',s);
  72.     delete(s,i,1);
  73.   end;
  74. end;
  75.  
  76. procedure checkbracketnum(s:sstring; var result:boolean);
  77. var lauf,lzu,i:integer;
  78. begin
  79.   lauf:=0;lzu:=0;i:=0;
  80.   result:=false;
  81.   repeat
  82.     i:=i+1;
  83.     if copy(s,i,1)='(' then
  84.       lauf:=lauf+1;
  85.     if copy(s,i,1)=')' then
  86.       lzu:=lzu+1;
  87.   until i>=length(s);
  88.   if lauf=lzu then
  89.     result:=true;
  90. end;
  91.  
  92. procedure checknum(s:sstring;var num:float;var result:boolean);
  93. var code,p,i:integer;  n:longint; num1:float;  s1,s2:sstring;
  94. begin
  95.   result:=false;
  96.   if s='Pi' then
  97.   begin
  98.     result:=true;
  99.     num:=Pi;
  100.     exit;
  101.   end
  102.   else
  103.   begin
  104.     val(s,num,code);
  105.     if code=0 then
  106.       result:=true;
  107.   end;
  108. end;
  109.  
  110. procedure checkparam(s:sstring; var parsort:word; var result:boolean);
  111. begin
  112.   result:=false;
  113.   if length(s)<>1 then exit else
  114.   begin
  115.     if s='A' then begin
  116.       result:=true; parsort:=1; exit; end;
  117.     if s='B' then begin
  118.       result:=true; parsort:=2; exit; end;
  119.     if s='C' then begin
  120.       result:=true; parsort:=3; exit; end;
  121.     if s='D' then begin
  122.       result:=true; parsort:=4; exit; end;
  123.     if s='E' then begin
  124.       result:=true; parsort:=5; exit; end;
  125.   end;
  126. end;
  127.  
  128.  
  129. procedure checkvar(s:sstring;var varsort:word;var result:boolean);
  130. begin
  131.   result:=false;
  132.   if length(s)<>1 then exit else
  133.   begin
  134.     if s='x' then
  135.     begin
  136.       result:=true;
  137.       varsort:=1;
  138.       exit;
  139.     end;
  140.     if s='y' then
  141.     begin
  142.       result:=true;
  143.       varsort:=2;
  144.       exit;
  145.     end;
  146.     if s='t' then
  147.     begin
  148.       result:=true;
  149.       varsort:=3;
  150.       exit;
  151.     end;
  152.   end;
  153. end;
  154.  
  155.  
  156.  
  157. procedure checkbrack(s:sstring;var s1:sstring;var result:boolean);
  158. var s2,s3:sstring;   num:float;  fsort:termsorttype; varsort:word;
  159. begin
  160.   result:=false;
  161.   if copy(s,1,1)='(' then
  162.     if copy(s,length(s),1)=')' then
  163.     begin
  164.       s1:=copy(s,2,length(s)-2);
  165.       checksum(s1,s2,s3,result); if result then exit;
  166.       checknum(s1,num,result); if result then exit;
  167.       checkdiff(s1,s2,s3,result); if result then exit;
  168.       checkmin(s1,s2,result);if result then exit;
  169.       checkprod(s1,s2,s3,result);if result then exit;
  170.       checkdiv(s1,s2,s3,result);if result then exit;
  171.       check2varfunct(s1,s2,s3,fsort,result);if result then exit;
  172.       checkfunct(s1,s2,fsort,result);if result then exit;
  173.       checkvar(s1,varsort,result);if result then exit;
  174.       checkparam(s1,varsort,result);if result then exit;
  175.       checkintpower(s1,s2,s3,result);if result then exit;
  176.       checkrealpower(s1,s2,s3,result);if result then exit;
  177.       checkbrack(s1,s2,result);
  178.       if result then begin s1:=s2;  exit; end;
  179.     end;
  180. end;
  181.  
  182. procedure checkmin(s:sstring;var s1:sstring;var result:boolean);
  183. var s2,s3:sstring;  num:float;   fsort:termsorttype; varsort:word;
  184. begin
  185.   result:=false;
  186.   if copy(s,1,1)='-' then
  187.   begin
  188.     s1:=copy(s,2,length(s)-1);
  189.     checkbrack(s1,s2,result);
  190.     if result then begin
  191.       s1:=s2;  exit; end;
  192.     checkvar(s1,varsort,result); if result then exit;
  193.     checkparam(s1,varsort,result); if result then exit;
  194.     checkfunct(s1,s2,fsort,result); if result then exit;
  195.     check2varfunct(s1,s2,s3,fsort,result); if result then exit;
  196.     checkintpower(s1,s2,s3,result); if result then exit;
  197.     checkrealpower(s1,s2,s3,result); if result then exit;
  198.   end;
  199. end;
  200.  
  201. procedure checksum(s:sstring;var s1,s2:sstring;var result:boolean);
  202. var s3,s4:sstring; i,j:byte; num:float;    fsort:termsorttype;varsort:word;
  203. begin
  204.   result:=false;
  205.   i:=0;
  206.   repeat
  207.     j:=pos('+',copy(s,i+1,length(s)-i));
  208.     if j>0 then
  209.     begin
  210.       i:=i+j;
  211.       if (i<length(s)) and (i>1) then
  212.       begin
  213.         s1:=copy(s,1,i-1);  s2:=copy(s,i+1,length(s)-i);
  214.         checkbracketnum(s1,result); if result then
  215.           checkbracketnum(s2,result); if result then
  216.         begin
  217.           checkvar(s1,varsort,result);
  218.           if not result then
  219.           checknum(s1,num,result);
  220.           if not result then
  221.           checkparam(s1,varsort,result);
  222.           if not result then
  223.           begin
  224.           checkbrack(s1,s3,result);
  225.           if result then s1:=s3; end;
  226.           if not result then
  227.           checkmin(s1,s3,result);
  228.           if not result then
  229.           checkdiff(s1,s3,s4,result);
  230.           if not result then
  231.           checkprod(s1,s3,s4,result);
  232.           if not result then
  233.           checkdiv(s1,s3,s4,result);
  234.           if not result then
  235.           check2varfunct(s1,s3,s4,fsort,result);
  236.           if not result then
  237.           checkfunct(s1,s3,fsort,result);
  238.           if not result then
  239.           checkintpower(s1,s3,s4,result);
  240.           if not result then
  241.             checkrealpower(s1,s3,s4,result);
  242.           if result then
  243.           begin
  244.             checkvar(s2,varsort,result); if result then exit;
  245.               checknum(s2,num,result);if result then exit;
  246.               checkparam(s2,varsort,result); if result then exit;
  247.               checkbrack(s2,s3,result);
  248.               if result then begin
  249.                 s2:=s3; exit; end;
  250.               checksum(s2,s3,s4,result);if result then exit;
  251.               checkdiff(s2,s3,s4,result);if result then exit;
  252.               checkprod(s2,s3,s4,result);if result then exit;
  253.               checkdiv(s2,s3,s4,result);if result then exit;
  254.               checkfunct(s2,s3,fsort,result);if result then exit;
  255.               check2varfunct(s2,s3,s4,fsort,result);if result then exit;
  256.               checkintpower(s2,s3,s4,result);if result then